perm filename HOMER[NEW,LCS] blob
sn#155912 filedate 1975-04-21 generic text, type T, neo UTF8
00010 RC←14
00100 ;;C****** FOR 'HOMING' OF BEAMS AND CHORD NOTES ***********
00200 ;; SUBROUTINE HOMER
00300 ;; IMPLICIT INTEGER(A-Q,S-Z)
00400 ;; REAL PWDS,DISX,A,B,PLACE,STFF
00500 ;; COMMON /STF/RSTFAC(-3/4),RSTJ2
00600 ;; COMMON R2,JA,CENTR,J2,RJQ(20),JQ(20) /POSI/STFF(-3/4),JJ2,POS
00700 ;; COMMON /XRN/RN(4000) /PTR/PWDS(250),ITEM,L,I,IX
00800 ;; COMMON/ALF/QQ(3),K,RA,RB,N,RG,M,X,RE,RF,A,B,DISX,INP(58)
00900 ;; EQUIVALENCE (R3,RJQ(1)),(R6,RJQ(4)),(J11,JQ(9)),(RD,RN(4000))
01000 ;; 1,(R7,RJQ(5)),(R9,RJQ(7)),(R11,RJQ(9)),(R13,RJQ(11))
01100 ;; 1,(J10,JQ(8)),(R8,RJQ(6)),(J7,JQ(5))
01200 HOMER: 0 ; IF(JA.EQ.6)GO TO 9
01210 MOVE MM,.COMM.+1
01220 CAIN MM,6
01230 JRST H9
01300 SKIPE .COMM.+=14 ;IF(R13.NE.0)GO TO 10
01310 JRST H10 ; FOR GENL HOMING; WORDS; BEAMS; STEMS;
01600 SKIPN .COMM.+=24 ;IF(JQ(1).EQ.0)GO TO 197
01610 JRST H197 ; TO HOME IN ON NOTE ON DIFFERENT STAFF.
01800 MOVE K,.COMM. ;JJ2=R2
01810 FIXX(K)
01820 MOVEM K,POSI+=8 ; JJ2 FOR RUNTHR
01900 MOVEI A,PTR ;K=PWDS(JJ2)
01910 ADDI K,(A)
02000 MOVEI L,PTR ;L=PWDS(JQ(1))
02010 ADD L,.COMM.+=24
02020 MOVEI JT,XRN ;RA=RN(K+3)
02030 ADDI JT,(K)
02040 MOVEM JT,UPDATE ;SAVE LOC OF RN(K+1)
02050 MOVE IS,2(JT)
02060 MOVEM IS,JIT ;RA SAVED IN JIT
02200 MOVEI JK,XRN ;RB=RN(L+3)
02210 ADDI JK,(L)
02220 MOVEM JK,NEWR ;LOC OF RN(L+1)
02300 MOVE IZ,2(JK) ; RB=POS OF NOTE, RA=POS(P3) OF BEAM
02310 MOVEM IZ,IK ; RB SAVED IN IK
02400 SETZM JUGGLE ;N=0
02500 MOVE 0,4(JK) ;IF(RN(L+5).LT.20)N=-1
02510 CAMGE 0,[=20.0]
02520 SETOM JUGGLE ; -1 MEANS STEM IS UP
02700 MOVN 0,6(JT) ;RG=-(AMOD(RN(K+7),10.)-1.)*11./7.
02710 MOVEM 0,XNOTE ;RN(K+7)
02720 JSA 16,AMOD
02730 JUMP XNOTE
02740 JUMP [=10.0]
02750 FSBR 0,[=1.0]
02760 FMPR 0,[=11.0]
02770 FDVR 0,[=7.0]
02780 MOVEM 0,SORT2 ;RG SAVED IN SORT2
02800 ; SPACE FOR THE NUMB. OF BEAMS
02900 MOVE L,NEWR ;J11=RN(L+2)
02910 MOVE JT,1(L)
02920 FIXX(JT) ; J11 IS IN JT
03000 SETZ MM, ;M=0
03100 MOVE K,UPATE ;IF(RN(K+7).LT.20.)M=-1
03110 MOVE JK,6(K) ;RN(K+7)
03120 CAMGE JK,[=20.0]
03130 SETO MM,
03200 MOVE JK,1(K) ;X=RN(K+2)
03210 FIXX(JK) ; X IS IN JK
03300 ; THE STAFF NUMS. X=BEAM J11=NOTE
03400 MOVEI IS,STF ;R3=RSTFAC(X)
03410 ADDI IS,(JK)
03420 MOVEI IS,3(IS) ;R3 IS IN 'IS'
03500 MOVEI IZ,STF ;R9=RSTFAC(J11)/R3
03510 ADDI IZ,(JT)
03520 MOVE IZ,3(IZ)
03530 FDVR IZ,IS ;R9 IS IN IZ
03600 FMPR IS,[=2.43959732] ;R8=R3*14.54/5.96
03700 ; R8=WIDTH OF NOTE
03800 ;******* 5/74 BOTH STAVES MUST BE SAME SIZE - MOST LIKELY ********
03900 MOVE A,[=13.7142857] ;R7=96./7.
04000 ;C MUST BE DOUBLE STEM LENGTH
04100 MOVE R,7(L) ;RD=RN(L+8)
04300 ; THE STEM LENGTH
04900 CAME MM,JUGGLE ;3 IF(M.NE.N)GO TO 5
04950 JRST H5
05000 SETZ IS, ;R8=0
05100 SETZ A, ;R7=0
05200 SETZM SORT2 ;RG=0
05300 JRST H4 ;GO TO 4
05400 H5: JUMPE MM,H4 ;5 IF(M.EQ.0)GO TO 4
05500 MOVNS A ; R7=-R7
05600 MOVNS IS ;R8=-R8
05700 MOVNS R ;RD=-RD
05800 MOVNS SORT2 ;RG=-RG
05900
06000 ; NOT OK IF DIFF SIZES AND RA.GT.RB ****** 5/74
06100 H4: FADR IS,IK ;4 RN(K+6)=RB+R8
06150 MOVEM IS,5(K) ;SETS CORRECT HORIZANTAL PARAM OF BEAM.
06300 MOVE J,IZ ;RF=7.*R9
06350 FMPR J,[=0.7)
06400 MOVEI NN,POSI ;RE=(STFF(J11)-STFF(X))/RF
06450 ADDI NN,(JT)
06460 MOVE NN,3(NN) ;STFF(J11)
06470 MOVEI MM,POSI
06480 ADDI MM,(JK)
06490 FSBR NN,3(MM)
06495 FDVR NN,J ;RE IS IN NN
06500 ; DIST BETWEEN STAVES.
06600 FADR A,R ;RN(K+5)=RN(L+4)+RE+(R7+RD+RG)*R9
06610 FADR A,SORT2
06620 FMPR A,IZ
06630 FADR A,NN
06640 FADR A,3(L)
06650 MOVEM A,4(K)
06700 JRA 16,(16) ;RETURN
06800
07000 ; NEXT ADJUSTS STEMS WHEN BEAMS ARE USED.
07100 H197: SETOM POSI+=8 ;197 JJ2=-1
07300 MOVE R,.COMM. ;R3=R2
07310 MOVEM R,JIT
07400 SETZ K, ;DO 191 K=1,ITEM
07410 H191: MOVEM K,LOOP ;SAVE K
07500 MOVEI L,PTR ; L=PWDS(K)
07510 ADDI L,(K)
07520 MOVE L,(L)
07530 FIXX(L)
07600 MOVEI R,XRN ;IF(RN(L+1).NE.6)GO TO 191
07610 ADDI R,(L) ;LOC OF RN(L+1)
07620 MOVE A,(R)
07630 CAME A,[=6.0]
07640 JRST HX191
07700 MOVE J,JIT ;IF(RN(L+2).EQ.R3)GO TO 77
07710 CAMN J,1(R)
07720 JRST H77
07800 CAMGE J,[=5.0] ;IF(R3.LT.5.)GO TO 191
07810 JRST HX191 ; TYPE 19 99 FOR ALL STAVES
08000 H77: MOVE J,-1(R) ;77
08010 CAMN J,[=8.0] ;IF(RN(L).EQ.8)GO TO 191
08200 MOVE J,6(R) ;IF(RN(L+7).LT.10.)GO TO 191
08300 CAMGE J,[=10.0] ;C FINDS BEAMS.
08310 JRST HX191
08320 FDVR J,[=10.0] ;X=RG/10.
08330 FIXX(J) ;C STEM DIRECT.
08335 MOVEM J,IK ;X SAVED IN IK
08340 MOVE J,1(R) ;R2=RN(L+2)
08350 MOVEM J,.COMM. ; USED IN 'FINDIT'
08400 MOVE A,2(R) ;A=RN(L+3)-.01
08410 FSBR A,[=0.01]
08420 MOVEM A,NEWR ;SAVE A IN NEWR
08500 MOVE J,5(R) ;B=RN(L+6)+.01
08600 FADR J,[=0.01] ;C POS 1 AND 2
08610 MOVEM J,BAUTO ;B SAVED IN BAUTO
08700 FSBR J,A ;DISX=B-A
08710 MOVEM J,UPDATE ;DISX SAVED IN UPDATE
08800 ; DISTANCE IN REAL STEPS
08810 MOVEM R,MVBX ;SAVE LOC OF RN(L+1)
08900 JSA 16,AMOD ;RB=AMOD(RN(L+5),100.0)
08910 JUMP 3(MVBX)
08920 JUMP [=100.0]
08930 MOVEM 0,JUGGLE ; THIS IS RF!!!!
09000 ; NOTE 2
09100 JSA 16,AMOD ;RF=AMOD(RN(L+4),100.0)
09110 JUMP 4(MVBX)
09120 JUMP [=100.0] ;0 WILL HAVE RB!!!
09130 FSBR 0,JUGGLE
09140 MOVEM 0,SORT2 ;RD SAVED IN SORT2 -- RD=RB-RF
09300 ; HEIGHT
09310 MOVEI NN,1
09900 H192: MOVEM NN,DPYNEW ; DO 192 N=1,ITEM
10100 JSA 16,FINDIT ;IF(FINDIT(N))GO TO 192
10110 JUMP DPYNEW
10120 JUMPL 0,HX192
10200 MOVEI R,XRN ;IF(RN(L).EQ.8)GO TO 192
10210 ADD R,PTR+=251 ;LOC OF RN(L+1)
10220 MOVE J,-1(R)
10230 CAMN J,[=8.0]
10240 JRST HX192
10300 MOVE J,7(R) ;IF(RN(L+8).EQ.1000.)GO TO 192
10310 CAMN J,[=1000.0]
10320 JRST HX192 ; SKIPS SLASHED GRACE NOTES (P8=1000 OR P10=1)
10500 ; FINDIT IS NEG. IF(RN(L+1).NE.1.OR.RN(L+3))
10600 MOVE A,2(R) ;RC=RN(L+3)
10700 CAMGE A,NEWR ;IF(RC.LT.A)GO TO 192
10710 JRST HX192
10800 CAMLE A,BAUTO ;IF(RC.GT.B)GO TO 192
10810 JRST HX192 ; WHAT'S LEFT IS IN BEAM AREA IF STEM DIR. IS OK.
11000 MOVE J,4(R) ;IF(X.NE.IFIX(RN(L+5)/10.))GO TO 192
11010 FDVR J,[=10.0]
11020 FIXX(J)
11030 CAME J,IK
11040 JRST HX192
11100 FSBR A,NEWR ;RC=RC-A
11110 MOVEM A,MVBEAM ;SAVES RC
11120 MOVEM R,MVBX ;SAVE LOC OF RN(L+1)
11200 JSA 16,AMOD ;193 RE=AMOD(RN(L+4),100.0)
11210 JUMP 3(MVBX)
11220 JUMP [=100.0]
11230 MOVEM 0,ALF+3 ;RE SAVE HERE
11300 MOVE J,SORT2 ;RC=RD*RC/DISX+RF
11310 FMPR J,MVBEAM ;*RC
11320 FDVR J,UPDATE ;/DISX
11330 FADR J,JUGGLE ;+RF
11340 MOVEM J,MVBEAM ;RC=
11400 MOVE J,6(MVBX) ;RG=RN(L+7)
11410 MOVEM J,ALF+4 ;SAVE RG
11500 JSA 16,AMOD ;RN(L+7)=RG-AMOD(RG,10.0)+AMOD(RG,1.0)
11510 JUMP ALF+4
11520 JUMP [=10.0]
11530 MOVEM 0,LUP2
11540 JSA 16,AMOD
11550 JUMP ALF+4
11560 JUMP [=1.0]
11570 FSBR 0,LUP2
11580 FADR 0,ALF+4
11590 MOVEM 0,6(MVBX) ;DELETES TAILS WITHOUT REMOVING DOTS OR SPACING OF DOTS.
11700 ; FRACTIONAL NOTE #
11800 MOVE R,MVBEAM ;195 RA=RC-RE
11810 FSBR R,ALF+3
11900 MOVE J,IK ;IF(X.EQ.2)RA=-RA
11910 CAIN J,2
11920 MOVNS R
12000 SKIPN R ;IF(RA.EQ.0)RA=999.
12010 MOVE R,[=999.0]
12020 MOVEM R,7(MVBX) ;196 RN(L+8)=RA
12090 ; FRACTIONAL NOTE # - FIRST NOTE OF GROUP + THIS NOTE # ALL *7.
12100 MOVE NN,DPYNEW ;IF(JJ2)JJ2=N
12110 SKIPGE POSI+=8
12120 MOVEM NN,POSI+=8 ; SAVES # OF FIRST ITEM FOUND
12500 HX192: CAMGE NN,PTR+=250 ;192 CONTINUE
12505 AOJA NN,H192
12600 HX191: MOVE K,LOOP ;191 CONTINUE
12610 CAMGE K,PTR+=250
12620 AOJA K,H191
12700 JRA 16,(16) ;RETURN
12800
13000 H9: SKIPGE .COMM.+=32 ;9 IF(J11.LT.0)RETURN
13010 JRA 16,(16) ; IF P11=-1 NO HOMING
13200 MOVE R,.COMM.+=8 ; X=R7/10.
13210 FDVR R,[=10.0]
13220 FIXX(R)
13300 SKIPGE R ;IF(X)X=-X
13310 MOVNS R
13320 MOVEM R,IK ;X SAVED IN IK
13400 ; X IS STEM DIRECTION
13500 MOVE L,.COMM.+=10 ;RA=R9
13600 ; R9= POS3
13700 MOVN RC,[=1.0] ;RC=-1.
13800 SKIPE L ;IF(R9.NE.0)RC=-2.
13810 MOVN R,[=2.0]
13900 MOVE J,.COMM.+=31 ;IF(J10/10.EQ.3)RC=-3
13910 IDIVI J,=10
13920 CAIN J,3
13930 MOVN R,[=3.0] ; RC=1 ESCAPES FROM LOOP.
14100 ; HOMING RANGE FOR BEAMS
14200 MOVE IS,.COMM.+=12 ;10 IF(R11.EQ.0)R11=2.9
14210 JUMPN IS,H10
14220 MOVE IS,[=2.9]
14230 MOVEM IS,.COMM.+=12 ; IF P11.NE.0 RANGE IS CHANGED FROM 2
14400 H10: MOVE IZ,.COMM.+1 ; IF(JA.EQ.5)RC=-1
14410 CAIN IZ,5
14420 MOVN RC,[=1.0]
14430 MOVEI K,1
14600 H361: JSA 16,FINDIT ;DO 361 K=1,ITEM
14610 JUMP K
14700 JUMPL 0,HX361 ;IF(FINDIT(K))GO TO 361
14800 ; SKIPS NOTES ON WRONG LINE
14900 MOVEI R,XRN ;RD=RN(L+3)
14910 ADD R,PTR+=251 ;LOC OF RN(L+1)
14920 MOVE A,2(R) ;RD IN A
15000 MOVEM A,XRN+=3999 ;1 IF(JA.NE.6)GO TO 177
15010 MOVE J,.COMM.+1
15020 CAIE J,6
15030 JRST H177
15100 MOVE J,4(R) ;IF(IFIX(RN(L+5)/10).NE.X)GO TO 361
15110 FDVR J,[=10.0]
15120 FIXX(J)
15130 CAME J,IK
15140 JRST HX361
15200 H177: JSA 16,PLACE ;177 IF(PLACE(R3))GO TO 461
15210 JUMP .COMM.+4
15220 JUMPL H461
15300 MOVEM A,.COMM.+4 ;R3=RD
15400 ; LOOKS FOR NOTE, STAFF #, STEM DIR.
15500 MOVE J,.COMM.+1 ;IF(JA.EQ.6)GO TO 861
15510 CAIN J,6
15520 JRST H861
15600 CAIN J,5 ;IF(JA.EQ.5)GO TO 261
15610 JRST H261
15700 JRA 16,(16) ;RETURN
15900 H461: MOVE J,.COMM.+1 ;461 IF(JA.EQ.6)GO TO 277
15910 CAIN J,6
15920 JRST H277
16000 CAIN J,5 ;IF(JA.NE.5)GO TO 361
16010 JRST HX361
16100 H277: JSA 16,PLACE ;277 IF(PLACE(R6))GO TO 561
16110 JUMP .COMM.+7
16120 JUMPL H561
16200 MOVEM A,.COMM.+7 ;R6=RD
16400 H861: MOVE 0,.COMM.+=28 ;861 IF(J7.GE.0)GO TO 261
16410 JUMPGE 0,H261
16500 H561: JSA 16,PLACE ;561 IF(PLACE(RA))GO TO 661
16510 JUMP L
16520 JUMPL H661
16600 MOVE 0,.COMM.+=28 ;IF(J7)GO TO 761
16610 JUMPL H761 ; J7=NEG MEANS TREMOLO
16800 MOVE 0,.COMM.+=9 ; IF(R8.EQ.0)GO TO 361
16810 JUMPE H361
16900 H761: MOVEM A,.COMM.+=10 ;761 R9=RD
17000 ; R8=0 MEANS R9 IS NUMBER OUTSIDE OF BEAM.
17100 JRST H261 ;GO TO 261
17200 H661: CAIN J,5 ;661 IF(JA.EQ.5)GO TO 361
17210 JRST HX361
17300 MOVE 0,.COMM.+=31 ;IF(J10.LT.30)GO TO 361
17310 CAIGE 0,=30
17320 JRST HX361
17400 JSA 16,PLACE ;IF(PLACE(R8))GO TO 361
17410 JUMP .COMM.+=9
17420 JUMPL HX361 ; HOMES INNER PARTIAL BEAMS
17600 MOVEM A,.COMM.+=9 ;R8=RD
17700 H261: FADR RC,[=1.0] ;261 RC=RC+1
17800 CAMN RC,[=1.0] ;IF(RC.EQ.1.)RETURN
17810 JRA 16,(16)
17900 HX361: CAMGE K,PTR+=250 ;361 CONTINUE
17910 AOJA K,H361
18000 JRA 16,(16) ; END
18010
18020 END